home *** CD-ROM | disk | FTP | other *** search
/ Ham Radio 2000 #1 / Ham Radio 2000.iso / ham2000 / packet / p_aa4re / bb212src / bbexdos.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-03-08  |  18.8 KB  |  613 lines
  1. (*===========================================================================*)
  2. (* Execute DOS command                                                       *)
  3. (*                                                                           *)
  4. (*   Copyright 1989, 1990, 1991 by H. Roy Engehausen.  All rights reserved.  *)
  5. (*                                                                           *)
  6. (*===========================================================================*)
  7.  
  8. {$UNDEF DEBUG}
  9. {$UNDEF DEBUG_2} (* Server names       *)
  10. {$UNDEF DEBUG_3} (* Server names again *)
  11. {$UNDEF MEMSIZE}
  12.  
  13. {$DEFINE POINT_CHK}
  14.  
  15. {$O+}
  16.  
  17. UNIT BBEXDOS;
  18.  
  19. INTERFACE
  20.  
  21. PROCEDURE exec_dos(cmd_string : STRING);
  22.  
  23. IMPLEMENTATION
  24.  
  25. USES
  26.   CRT,
  27.   DOS,
  28.   bbdummy,
  29.   bbexport,
  30.   bbimport,
  31.   bbmdata,
  32.   bbmess,
  33.   bbmfi,
  34.   bbmisc,
  35.   bbmisc2,
  36.   bbmisc3,
  37.   bbmisc5,
  38.   bbrunerr,
  39.   bbsdata,
  40.   bbsema2,
  41.   bbstr,
  42.   bbtime,
  43.   bbwin;
  44.  
  45.  
  46. (*===========================================================================*)
  47. (* Execute a dos program                                                     *)
  48. (*===========================================================================*)
  49.  
  50. PROCEDURE exec_dos(cmd_string : STRING);
  51.  
  52.   CONST
  53.     max_block = 4095;
  54.     overage   = 16;
  55.  
  56.   TYPE
  57.     param_block_type = RECORD                         (* DOS parameter block *)
  58.                          Environment_Ptr  : WORD;
  59.                          Command_Line_Ptr : POINTER;
  60.                          FCB1             : POINTER;
  61.                          FCB2             : POINTER;
  62.                        END;
  63.  
  64.   VAR
  65.     d_err        : INTEGER;
  66.     i            : INTEGER;
  67.     j            : WORD;
  68.     opt_string   : str8;
  69.     p            : POINTER;
  70.     param_block  : param_block_type;
  71.     program_name : file_name_str;
  72.     regs         : REGISTERS;
  73.     s            : STRING[10];
  74.     save_cons    : BOOLEAN;
  75.     save_pchn    : STRING[2];
  76.     save_port    : port_block_ptr;
  77.     server_mode  : BOOLEAN;
  78.     server_name  : STRING[8];
  79.     swap_bot     : WORD;
  80.     swap_top     : WORD;
  81.     swap_file    : FILE;
  82.     swap_size    : WORD;
  83.  
  84.   PROCEDURE clean_up;
  85.     BEGIN;
  86.       active_tcb^.tcb_console := save_cons;
  87.       active_port             := save_port;
  88.       active_tcb^.tcb_port    := active_port;
  89.       active_tcb^.port_chan_s := save_pchn;
  90.       free_semaphore(semaphore_interrupts);
  91.     END;
  92.  
  93.   BEGIN;
  94.  
  95.     (*-----------------------------------------------------------------------*)
  96.     (* Server mode?                                                          *)
  97.     (*-----------------------------------------------------------------------*)
  98.  
  99.     s := SUBWORD(@cmd_string, 1, 1);
  100.     upcase_str_var(s);
  101.     server_mode := NOT (s = 'EX');
  102.  
  103.     (*-----------------------------------------------------------------------*)
  104.     (* Get options (if any)                                                  *)
  105.     (*-----------------------------------------------------------------------*)
  106.  
  107.     opt_string := get_option_string(cmd_string);
  108.  
  109.     IF server_mode AND (opt_string = '') THEN
  110.       BEGIN;
  111.         IF s = 'EL' THEN
  112.           opt_string := '[L]'
  113.         ELSE
  114.           opt_string := '[EKIZ]';
  115.       END;
  116.  
  117.     upcase_str_var(opt_string);
  118.  
  119.     (*-----------------------------------------------------------------------*)
  120.     (* See if valid parms                                                    *)
  121.     (*-----------------------------------------------------------------------*)
  122.  
  123.     IF (words(cmd_string) < 2)
  124.                              OR (server_mode AND (words(cmd_string) < 3)) THEN
  125.       BEGIN;
  126.         send_message(message_not_en);
  127.         active_tcb^.error_sw := TRUE;
  128.         EXIT;
  129.       END;
  130.  
  131.     (*-----------------------------------------------------------------------*)
  132.     (* See if we can run.                                                    *)
  133.     (*-----------------------------------------------------------------------*)
  134.  
  135.     IF (POS('A', opt_string) = 0) AND bbs_busy THEN
  136.       BEGIN;
  137.  
  138.         {$IFDEF DEBUG}
  139.           WRITELN('EX Busy');
  140.         {$ENDIF}
  141.  
  142.         send_message(message_other_active);
  143.         active_tcb^.error_sw := TRUE;
  144.         wakeup_did_something := FALSE;
  145.         EXIT;
  146.  
  147.       END;
  148.  
  149.     (*-----------------------------------------------------------------------*)
  150.     (* Initialize                                                            *)
  151.     (*-----------------------------------------------------------------------*)
  152.  
  153.     save_cons               := active_tcb^.tcb_console;
  154.     save_port               := active_port;
  155.     save_pchn               := active_tcb^.port_chan_s;
  156.     active_tcb^.tcb_console := TRUE;
  157.     active_port             := @dummy_port;
  158.     active_tcb^.tcb_port    := active_port;
  159.     active_tcb^.port_chan_s := 'EX';
  160.  
  161.     (*-----------------------------------------------------------------------*)
  162.     (* Break out the names                                                   *)
  163.     (*-----------------------------------------------------------------------*)
  164.  
  165.     {$IFDEF DEBUG_2} (* Server names *)
  166.       WRITELN;
  167.       WRITELN('cmds = ', cmd_string);
  168.       WRITELN('Servermode = ', server_mode);
  169.       WRITELN('options = ', opt_string);
  170.       DELAY(1000);
  171.     {$ENDIF}
  172.  
  173.     IF server_mode THEN
  174.       BEGIN;
  175.         server_name  := subword(@cmd_string, 2, 1);
  176.         program_name := subword(@cmd_string, 3, 1);
  177.         cmd_string   := subword(@cmd_string, 4, 0);
  178.       END
  179.     ELSE
  180.       BEGIN;
  181.  
  182.         program_name := subword(@cmd_string, 2, 1);
  183.         cmd_string   := subword(@cmd_string, 3, 0);
  184.  
  185.         i := POS('\', program_name);
  186.         IF i = 0 THEN
  187.           i := POS(':', program_name);
  188.         IF i = 0 THEN
  189.           i := 1;
  190.  
  191.         server_name := COPY(program_name, i, 255);
  192.         i := POS('.', server_name);
  193.         IF i > 1 THEN
  194.           server_name := COPY(server_name, 1, i-1);
  195.  
  196.       END;
  197.  
  198.     {$IFDEF DEBUG_2} (* Server names *)
  199.       WRITELN('server_name = ', server_name);
  200.       WRITELN('program_name = ', program_name);
  201.       WRITELN('cmd_string = ', cmd_string);
  202.       DELAY(1000);
  203.     {$ENDIF}
  204.  
  205.     {$IFDEF DEBUG_3} (* Server names *)
  206.       send_data_tnc_str('Server = ' + server_name
  207.                          + '-- Program = ' + program_name+ cr);
  208.     {$ENDIF}
  209.  
  210.     (*-----------------------------------------------------------------------*)
  211.     (* Do EXPORT as needed                                                   *)
  212.     (*-----------------------------------------------------------------------*)
  213.  
  214.     IF POS('E', opt_string) > 0 THEN
  215.       BEGIN;
  216.  
  217.         IF POS('K', opt_string) > 0 THEN
  218.           s := 'EXPORTK '
  219.         ELSE
  220.           s := 'EXPORT ';
  221.  
  222.         {$IFDEF DEBUG_3} (* Server names *)
  223.           send_data_tnc_str(s + server_name + '.IN E ' + server_name + cr);
  224.         {$ENDIF}
  225.  
  226.         export_cmd(s + server_name + '.IN E ' + server_name, NIL);
  227.  
  228.         active_tcb^.error_sw := FALSE;
  229.  
  230.       END;
  231.  
  232.     (*-----------------------------------------------------------------------*)
  233.     (* If no input file then we can skip                                     *)
  234.     (*-----------------------------------------------------------------------*)
  235.  
  236.     IF (POS('Q', opt_string) > 0)
  237.                                  AND (file_test(server_name + '.IN') <> 0) THEN
  238.       BEGIN;
  239.         send_tnc_data_str('No input file for server.  Operation terminated'
  240.                            + cr);
  241.         EXIT;
  242.       END;
  243.  
  244.     (*-----------------------------------------------------------------------*)
  245.     (* Resolve program name                                                  *)
  246.     (*-----------------------------------------------------------------------*)
  247.  
  248.     upcase_str_var(program_name);
  249.  
  250.     IF program_name = 'DOS' THEN
  251.       BEGIN;
  252.         program_name := GETENV('COMSPEC');
  253.         cmd_string   := '/C ' + cmd_string;
  254.       END
  255.     ELSE
  256.       program_name := FSEARCH(program_name, GETENV('PATH'));
  257.  
  258.     IF program_name = '' THEN
  259.       BEGIN;
  260.         send_message(message_dos_ex_file_nf);
  261.         EXIT;
  262.       END;
  263.  
  264. (*  program_name := FSEARCH(program_name, GETENV(s)); *)
  265.  
  266.     send_tnc_data_str('PGM = ' + program_name + cr);
  267.     send_tnc_data_str('CMD = ' + cmd_string + cr);
  268.  
  269.     (*-----------------------------------------------------------------------*)
  270.     (* Calculate swap size                                                   *)
  271.     (*-----------------------------------------------------------------------*)
  272.  
  273.     swap_bot  := active_tcb^.sptr_init;
  274.     swap_bot  := swap_bot DIV 16 + SSEG + 8;
  275.  
  276.     {$IFDEF VER55}
  277.       swap_top  := SEG(FREEPTR^) + $1000;
  278.     {$ELSE}
  279.       swap_top := SEG(HEAPEND^);
  280.     {$ENDIF}
  281.  
  282.     swap_size := swap_top - swap_bot;
  283.  
  284.     {$IFDEF MEMSIZE}
  285.       STR(LONGINT(swap_bot) * 16, s);
  286.       send_tnc_data_str('Execute DOS -- Bottom = ' + s + cr);
  287.  
  288.       STR(LONGINT(swap_top) * 16, s);
  289.       send_tnc_data_str('Execute DOS -- Top    = ' + s + cr);
  290.     {$ENDIF}
  291.  
  292.     (*-----------------------------------------------------------------------*)
  293.     (* Tell user we are running                                              *)
  294.     (*-----------------------------------------------------------------------*)
  295.  
  296.     STR(LONGINT(swap_size) * 16, s);
  297.  
  298.     {$IFDEF DEBUG}
  299.       WRITELN('EX Send 1');
  300.     {$ENDIF}
  301.  
  302.     send_tnc_data_str('Execute DOS processing started -- Memsize = '
  303.                        + s + cr);
  304.  
  305.     {$IFDEF DEBUG}
  306.       WRITELN('EX Drain 1');
  307.     {$ENDIF}
  308.  
  309.     send_drain;
  310.  
  311.     (*-----------------------------------------------------------------------*)
  312.     (* Obtain the interrupt lock                                             *)
  313.     (*-----------------------------------------------------------------------*)
  314.  
  315.     {$IFDEF DEBUG}
  316.       WRITELN('EX I Lock');
  317.     {$ENDIF}
  318.  
  319.     get_semaphore(semaphore_interrupts, sem_exclusive, FALSE);
  320.  
  321.     (*-----------------------------------------------------------------------*)
  322.     (* Open swap file                                                        *)
  323.     (*-----------------------------------------------------------------------*)
  324.  
  325.     {$IFDEF DEBUG}
  326.       WRITELN('EX Swap open');
  327.     {$ENDIF}
  328.  
  329.     ASSIGN(swap_file,  'SWAP.BB');
  330.  
  331.     {$I-}
  332.     REWRITE(swap_file, 16);
  333.     i := IORESULT;
  334.     {$I+}
  335.  
  336.     IF i <> 0 THEN
  337.       BEGIN;
  338.         send_tnc_data_str('I/O error on SWAP output file' + cr);
  339.         send_tnc_data_str(dos_err_message(i) + cr);
  340.         clean_up;
  341.         EXIT;
  342.       END;
  343.  
  344.     (*-----------------------------------------------------------------------*)
  345.     (* Swap write out                                                        *)
  346.     (*-----------------------------------------------------------------------*)
  347.  
  348.     j := swap_size;
  349.     p := PTR(swap_bot, 0);
  350.  
  351.     {$IFDEF POINT_CHK}
  352.       test_pointer(p);
  353.     {$ENDIF}
  354.  
  355.     WHILE j >= max_block DO
  356.       BEGIN;
  357.         BLOCKWRITE(swap_file, p^, max_block);
  358.         DEC(j, max_block);
  359.         p := PTR(SEG(p^) + max_block, OFS(p^));
  360.       END;
  361.     IF j > 0 THEN
  362.       BLOCKWRITE(swap_file, p^, j);
  363.  
  364.     (*-----------------------------------------------------------------------*)
  365.     (* Swap write out complete                                               *)
  366.     (*-----------------------------------------------------------------------*)
  367.  
  368.     CLOSE(swap_file);
  369.  
  370.     {$IFDEF DEBUG}
  371.       WRITELN('Swapout done');
  372.       DELAY(1000);
  373.     {$ENDIF}
  374.  
  375.     (*-----------------------------------------------------------------------*)
  376.     (* Shrink the memory size                                                *)
  377.     (*-----------------------------------------------------------------------*)
  378.  
  379.     WITH regs DO
  380.       BEGIN
  381.         AX := $4A00;                          (* DOS function 4Ah - SETBLOCK *)
  382.         ES := PREFIXSEG;                      (* location of our memory block*)
  383.         BX := swap_bot + overage - PREFIXSEG; (* Size we want                *)
  384.         MSDOS(regs);
  385.         IF (FLAGS AND $0001) <> 0 THEN        (* if carry is set then error  *)
  386.           BEGIN
  387.             AX := $5900;                      (* DOS 59h - Get Extended Err  *)
  388.             MSDOS(regs);
  389.             WRITELN('Critical error on DOS execute shrink');
  390.             WRITELN('AX = ', AX, ' -- BH = ', bh, ' -- BL = ', bl);
  391.             HALT;
  392.           END
  393.       END;
  394.  
  395.     {$IFDEF DEBUG}
  396.       WRITELN('Shrink done');
  397.       DELAY(1000);
  398.     {$ENDIF}
  399.  
  400.     (*-----------------------------------------------------------------------*)
  401.     (* Execute                                                               *)
  402.     (*-----------------------------------------------------------------------*)
  403.  
  404.     SWAPVECTORS;
  405.     EXEC(program_name, cmd_string);
  406.     SWAPVECTORS;
  407.  
  408.     {$IFDEF DEBUG}
  409.       WRITELN('EXEC back');
  410.       DELAY(1000);
  411.     {$ENDIF}
  412.  
  413.     d_err := DOSERROR;
  414.  
  415.     (*-----------------------------------------------------------------------*)
  416.     (* Grow the memory size                                                  *)
  417.     (*-----------------------------------------------------------------------*)
  418.  
  419.     WITH regs DO
  420.       BEGIN
  421.         AX := $4A00;                          (* DOS function 4Ah - SETBLOCK *)
  422.         ES := PREFIXSEG;                      (* location of our memory block*)
  423.         BX := swap_top - PREFIXSEG;           (* Size we want                *)
  424.         MSDOS(regs);
  425.         IF (FLAGS AND $0001) <> 0 THEN        (* if carry is set then error  *)
  426.           BEGIN
  427.             AX := $5900;                      (* DOS 59h - Get Extended Err  *)
  428.             MSDOS(regs);
  429.             WRITELN('Critical error on DOS execute grow');
  430.             WRITELN('AX = ', AX, ' -- BH = ', bh, ' -- BL = ', bl);
  431.             HALT;
  432.           END
  433.       END;
  434.  
  435.     {$IFDEF DEBUG}
  436.       WRITELN('GROW done');
  437.       DELAY(1000);
  438.     {$ENDIF}
  439.  
  440.     (*-----------------------------------------------------------------------*)
  441.     (* Open swap file                                                        *)
  442.     (*-----------------------------------------------------------------------*)
  443.  
  444.     {$I-}
  445.     RESET(swap_file, 16);
  446.     i := IORESULT;
  447.     {$I+}
  448.  
  449.     IF i <> 0 THEN
  450.       BEGIN;
  451.         send_tnc_data_str('I/O error on SWAP input file' + cr);
  452.         send_tnc_data_str(dos_err_message(i) + cr);
  453.         RUNERROR(swp_error);
  454.       END;
  455.  
  456.     (*-----------------------------------------------------------------------*)
  457.     (* Swap read in                                                          *)
  458.     (*-----------------------------------------------------------------------*)
  459.  
  460.     j := swap_size;
  461.     p := PTR(swap_bot, 0);
  462.  
  463.     {$IFDEF POINT_CHK}
  464.       test_pointer(p);
  465.     {$ENDIF}
  466.  
  467.     WHILE j >= max_block DO
  468.       BEGIN;
  469.         BLOCKREAD(swap_file, p^, max_block);
  470.         DEC(j, max_block);
  471.         p := PTR(SEG(p^) + max_block, OFS(p^));
  472.       END;
  473.     IF j > 0 THEN
  474.       BLOCKREAD(swap_file, p^, j);
  475.  
  476.     {$IFDEF DEBUG}
  477.       WRITELN('SWAP in done');
  478.       DELAY(1000);
  479.     {$ENDIF}
  480.  
  481.     (*-----------------------------------------------------------------------*)
  482.     (* Swap read in complete                                                 *)
  483.     (*-----------------------------------------------------------------------*)
  484.  
  485.     CLOSE(swap_file);
  486.     ERASE(swap_file);
  487.  
  488.     IF d_err = 2 THEN
  489.       BEGIN;
  490.         send_message(message_file_no_exist);
  491.         active_tcb^.error_sw := TRUE;
  492.         clean_up;
  493.         EXIT;
  494.       END;
  495.  
  496.     IF d_err = 8 THEN
  497.       BEGIN;
  498.         send_tnc_data_str('Not enough memory' + cr);
  499.         send_flush;
  500.         active_tcb^.error_sw := TRUE;
  501.         clean_up;
  502.         EXIT;
  503.       END;
  504.  
  505.     IF d_err <> 0 THEN
  506.       BEGIN;
  507.         WRITELN('Critical error on DOS execute -- ', d_err);
  508.         HALT;
  509.       END;
  510.  
  511.     (*-----------------------------------------------------------------------*)
  512.     (* clock update                                                          *)
  513.     (*-----------------------------------------------------------------------*)
  514.  
  515.     time_check;
  516.  
  517.     {$IFDEF DEBUG}
  518.       WRITELN('Time check done');
  519.       DELAY(1000);
  520.     {$ENDIF}
  521.  
  522.     (*-----------------------------------------------------------------------*)
  523.     (* Force window things                                                   *)
  524.     (*-----------------------------------------------------------------------*)
  525.  
  526.     status_window_change := TRUE;
  527.  
  528.     (*-----------------------------------------------------------------------*)
  529.     (* Clean things up                                                       *)
  530.     (*-----------------------------------------------------------------------*)
  531.  
  532.     clean_up;
  533.  
  534.     {$IFDEF DEBUG}
  535.       WRITELN('cleanup done');
  536.       DELAY(1000);
  537.     {$ENDIF}
  538.  
  539.     (*-----------------------------------------------------------------------*)
  540.     (* Rewrite windows                                                       *)
  541.     (*-----------------------------------------------------------------------*)
  542.  
  543.     i := who_is_in_window(window_top_screen);
  544.     window_select(i);
  545.     CLRSCR;
  546.     window_refresh(i);
  547.  
  548.     i := who_is_in_window(window_bottom_screen);
  549.     window_select(i);
  550.     window_refresh(i);
  551.  
  552.     {$IFDEF DEBUG}
  553.       WRITELN('Window done');
  554.       DELAY(1000);
  555.     {$ENDIF}
  556.  
  557.     (*-----------------------------------------------------------------------*)
  558.     (* Tell user we are done                                                 *)
  559.     (*-----------------------------------------------------------------------*)
  560.  
  561.     send_tnc_data_str('DOS processing ended' + cr);
  562.  
  563.     IF active_tcb^.error_sw THEN
  564.       BEGIN;
  565.         send_tnc_data_str('DOS program terminated with error' + cr);
  566.         send_flush;
  567.         EXIT;
  568.       END;
  569.  
  570.     send_flush;
  571.  
  572.     (*-----------------------------------------------------------------------*)
  573.     (* Do reload as needed                                                   *)
  574.     (*-----------------------------------------------------------------------*)
  575.  
  576.     IF POS('L', opt_string) > 0 THEN
  577.       BEGIN;
  578.  
  579.         cmd_string := 'GL';
  580.         oper_gm(cmd_string);
  581.  
  582.         active_tcb^.error_sw := FALSE;
  583.  
  584.       END;
  585.  
  586.     (*-----------------------------------------------------------------------*)
  587.     (* Do IMPORT as needed                                                   *)
  588.     (*-----------------------------------------------------------------------*)
  589.  
  590.     IF POS('I', opt_string) > 0 THEN
  591.       BEGIN;
  592.  
  593.         IF POS('Z', opt_string) > 0 THEN
  594.           s := 'IMPORTES '
  595.         ELSE
  596.           s := 'IMPORTS ';
  597.  
  598.         cmd_string := s + server_name + '.OUT';
  599.  
  600.         {$IFDEF DEBUG_3} (* Server names *)
  601.           send_data_tnc_str(cmd_string + cr);
  602.         {$ENDIF}
  603.  
  604.         import_cmd(cmd_string);
  605.  
  606.         active_tcb^.error_sw := FALSE;
  607.  
  608.       END;
  609.  
  610.   END;
  611.  
  612. END.
  613.